home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / electric / ehelp.el < prev    next >
Encoding:
Text File  |  1995-05-12  |  11.4 KB  |  342 lines
  1. ;;; ehelp.el --- bindings for electric-help mode
  2.  
  3. ;; Copyright (C) 1986 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Richard Mlynarik <mly@ai.mit.edu>
  6.  
  7. ;; Maintainer: FSF
  8. ;; Keywords: help, extensions
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; Synched up with: FSF 19.28.
  27.  
  28. ;;; Commentary:
  29.  
  30. ;; This package provides a pre-packaged `Electric Help Mode' for
  31. ;; browsing on-line help screens.  There is one entry point,
  32. ;; `with-electric-help'; All you have to give it is a no-argument
  33. ;; function that generates the actual text of the help into the current
  34. ;; buffer.
  35.  
  36. ;;; Code:
  37.  
  38. (require 'electric)
  39.  
  40. (defvar electric-help-map nil
  41.   "Keymap defining commands available in `electric-help-mode'.")
  42.  
  43. (put 'electric-help-undefined 'suppress-keymap t)
  44. (if electric-help-map
  45.     ()
  46.   (let ((map (make-keymap)))
  47.     (set-keymap-name map 'electric-help-map)
  48.     (let ((i 0))
  49.       (while (< i 128)
  50.     (define-key map (make-string 1 i) 'electric-help-undefined)
  51.     (setq i (1+ i))))
  52.     ;;#### Urk!  There should be a better way in Lucid Emacs!
  53.     (define-key map (char-to-string meta-prefix-char) (copy-keymap map))
  54.     (define-key map (char-to-string help-char) 'electric-help-help)
  55.     (define-key map "?" 'electric-help-help)
  56.     (define-key map " " 'scroll-up)
  57.     (define-key map "\^?" 'scroll-down)
  58.     (define-key map "." 'beginning-of-buffer)
  59.     (define-key map "<" 'beginning-of-buffer)
  60.     (define-key map ">" 'end-of-buffer)
  61.     ;(define-key map "\C-g" 'electric-help-exit)
  62.     (define-key map "q" 'electric-help-exit)
  63.     (define-key map "Q" 'electric-help-exit)
  64.     ;;a better key than this?
  65.     (define-key map "r" 'electric-help-retain)
  66.  
  67.     (setq electric-help-map map)))
  68.    
  69. (defun electric-help-mode ()
  70.   "`with-electric-help' temporarily places its buffer in this mode.
  71. \(On exit from `with-electric-help', the buffer is put in `default-major-mode'.\)"
  72.   (setq buffer-read-only t)
  73.   (setq mode-name "Help")
  74.   (setq major-mode 'help)
  75.   (setq mode-line-buffer-identification '(" Help:  %b"))
  76.   (use-local-map electric-help-map)
  77.   ;; this is done below in with-electric-help
  78.   ;(run-hooks 'electric-help-mode-hook)
  79.   )
  80.  
  81. (defun with-electric-help (thunk &optional buffer noerase)
  82.   "Arguments are THUNK &optional BUFFER NOERASE.
  83. BUFFER defaults to \"*Help*\"
  84. THUNK is a function of no arguments which is called to initialise
  85.  the contents of BUFFER.  BUFFER will be erased before THUNK is called unless
  86.  NOERASE is non-nil.  THUNK will be called with `standard-output' bound to
  87.  the buffer specified by BUFFER
  88.  
  89. After THUNK has been called, this function \"electrically\" pops up a window
  90. in which BUFFER is displayed and allows the user to scroll through that buffer
  91. in electric-help-mode.
  92. When the user exits (with `electric-help-exit', or otherwise) the help
  93. buffer's window disappears (ie we use `save-window-excursion')
  94. BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit."
  95.   (setq buffer (get-buffer-create (or buffer "*Help*")))
  96.   (let ((one (one-window-p t))
  97.         (config (current-window-configuration))
  98.         (bury nil))
  99.     (unwind-protect
  100.     (save-excursion
  101.       (if one (goto-char (window-start (selected-window))))
  102.       (let ((pop-up-windows t))
  103.         (pop-to-buffer buffer))
  104.       (save-excursion
  105.         (set-buffer buffer)
  106.         (electric-help-mode)
  107.         (setq buffer-read-only nil)
  108.         (or noerase (erase-buffer)))
  109.         (let ((standard-output buffer))
  110.           (if (not (funcall thunk))
  111.               (progn
  112.             (set-buffer buffer)
  113.             (set-buffer-modified-p nil)
  114.             (goto-char (point-min))
  115.             (if one (shrink-window-if-larger-than-buffer (selected-window))))))
  116.         (set-buffer buffer)
  117.         (run-hooks 'electric-help-mode-hook)
  118.                    (if (eq (car-safe (electric-help-command-loop))
  119.                    'retain)
  120.                (setq config (current-window-configuration))
  121.                (setq bury t)))
  122.       (message nil)
  123.       (set-buffer buffer)
  124.       (setq buffer-read-only nil)
  125.       (condition-case ()
  126.       (funcall (or default-major-mode 'fundamental-mode))
  127.     (error nil))
  128.       (set-window-configuration config)
  129.       (if bury
  130.           (progn
  131.             ;;>> Perhaps this shouldn't be done.
  132.             ;; so that when we say "Press space to bury" we mean it
  133.             (replace-buffer-in-windows buffer)
  134.             ;; must do this outside of save-window-excursion
  135.             (bury-buffer buffer))))))
  136.  
  137. (defun electric-help-command-loop ()
  138.   (catch 'exit
  139.     (if (pos-visible-in-window-p (point-max))
  140.     (progn (message "<<< Press Space to bury the help buffer >>>")
  141.            (if (eq (event-to-character
  142.             (setq unread-command-event (next-command-event)))
  143.                ?\ )
  144.            (progn (setq unread-command-event nil)
  145.               (throw 'exit t)))))
  146.     (let (up down both neither
  147.       (standard (and (eq (key-binding " ")
  148.                  'scroll-up)
  149.              (eq (key-binding "\^?")
  150.                  'scroll-down)
  151.              (eq (key-binding "Q")
  152.                  'electric-help-exit)
  153.              (eq (key-binding "q")
  154.                  'electric-help-exit))))
  155.       (Electric-command-loop
  156.         'exit
  157.     (function (lambda ()
  158.       (let ((min (pos-visible-in-window-p (point-min)))
  159.         (max (pos-visible-in-window-p (point-max))))
  160.         (cond ((and min max)
  161.            (cond (standard "Press Q to exit ")
  162.              (neither)
  163.              (t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
  164.           (min
  165.            (cond (standard "Press SPC to scroll, Q to exit ")
  166.              (up)
  167.              (t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
  168.           (max
  169.            (cond (standard "Press DEL to scroll back, Q to exit ")
  170.              (down)
  171.              (t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
  172.           (t
  173.            (cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
  174.              (both)
  175.              (t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
  176.             t))))
  177.  
  178.  
  179.  
  180. ;(defun electric-help-scroll-up (arg)
  181. ;  "####Doc"
  182. ;  (interactive "P")
  183. ;  (if (and (null arg) (pos-visible-in-window-p (point-max)))
  184. ;      (electric-help-exit)
  185. ;    (scroll-up arg)))
  186.  
  187. (defun electric-help-exit ()
  188.   "####Doc"
  189.   (interactive)
  190.   (throw 'exit t))
  191.  
  192. (defun electric-help-retain ()
  193.   "Exit `electric-help', retaining the current window/buffer configuration.
  194. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
  195. will select it.)"
  196.   (interactive)
  197.   (throw 'exit '(retain)))
  198.  
  199.  
  200. ;(defun electric-help-undefined ()
  201. ;  (interactive)
  202. ;  (let* ((keys (this-command-keys))
  203. ;     (n (length keys)))
  204. ;    (if (or (= n 1)
  205. ;        (and (= n 2)
  206. ;         meta-flag
  207. ;         (eq (aref keys 0) meta-prefix-char)))
  208. ;    (setq unread-command-char last-input-char
  209. ;          current-prefix-arg prefix-arg)
  210. ;      ;;#### I don't care.
  211. ;      ;;#### The emacs command-loop is too much pure pain to
  212. ;      ;;#### duplicate
  213. ;      ))
  214. ;  (throw 'exit t))
  215.  
  216. (defun electric-help-undefined ()
  217.   (interactive)
  218.   (error "%s is undefined -- Press %s to exit"
  219.      (mapconcat 'single-key-description (this-command-keys) " ")
  220.      (if (eq (key-binding "Q") 'electric-help-exit)
  221.          "Q"
  222.        (substitute-command-keys "\\[electric-help-exit]"))))
  223.  
  224.  
  225. ;#### this needs to be hairified (recursive help, anybody?)
  226. (defun electric-help-help ()
  227.   (interactive)
  228.   (if (and (eq (key-binding "Q") 'electric-help-exit)
  229.        (eq (key-binding " ") 'scroll-up)
  230.        (eq (key-binding "\^?") 'scroll-down))
  231.       (message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
  232.     ;; to give something for user to look at while slow substitute-cmd-keys
  233.     ;;  grinds away
  234.     (message "Help...")
  235.     (message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
  236.   (sit-for 2))
  237.  
  238.  
  239. (defun electric-helpify (fun &optional buffer-name)
  240.   (or buffer-name (setq buffer-name "*Help*"))
  241.   (let* ((p (symbol-function 'print-help-return-message))
  242.          (b (get-buffer buffer-name))
  243.          (tick (and b (buffer-modified-tick b))))
  244.     (and b (not (get-buffer-window b))
  245.          (setq b nil))
  246.     (if (unwind-protect
  247.              (save-window-excursion
  248.                (message "%s..." (capitalize (symbol-name fun)))
  249.                ;; kludge-o-rama
  250.                (fset 'print-help-return-message 'ignore)
  251.                (let ((a (call-interactively fun 'lambda)))
  252.                  (let ((temp-buffer-show-function 'ignore))
  253.                    (apply fun a)))
  254.                (message nil)
  255.                ;; Was a non-empty help buffer created/modified?
  256.                (let ((r (get-buffer buffer-name)))
  257.                  (and r
  258.                       ;(get-buffer-window r)
  259.                       (or (not b)
  260.                           (not (eq b r))
  261.                           (not (eql tick (buffer-modified-tick b))))
  262.                       (save-excursion
  263.                         (set-buffer r)
  264.                         (> (buffer-size) 0)))))
  265.           (fset 'print-help-return-message p))
  266.         (with-electric-help 'ignore buffer-name t))))
  267.  
  268.  
  269. (defun electric-describe-key ()
  270.   (interactive)
  271.   (electric-helpify 'describe-key))
  272.  
  273. (defun electric-describe-mode ()
  274.   (interactive)
  275.   (electric-helpify 'describe-mode))
  276.  
  277. (defun electric-view-lossage ()
  278.   (interactive)
  279.   (electric-helpify 'view-lossage))
  280.  
  281. ;(defun electric-help-for-help ()
  282. ;  "See help-for-help"
  283. ;  (interactive)
  284. ;  )
  285.  
  286. (defun electric-describe-function ()
  287.   (interactive)
  288.   (electric-helpify 'describe-function))
  289.  
  290. (defun electric-describe-variable ()
  291.   (interactive)
  292.   (electric-helpify 'describe-variable))
  293.  
  294. (defun electric-describe-bindings ()
  295.   (interactive)
  296.   (electric-helpify 'describe-bindings))
  297.  
  298. (defun electric-describe-syntax ()
  299.   (interactive)
  300.   (electric-helpify 'describe-syntax))
  301.  
  302. (defun electric-command-apropos ()
  303.   (interactive)
  304.   (electric-helpify 'command-apropos))
  305.  
  306. ;(define-key help-map "a" 'electric-command-apropos)
  307.  
  308.  
  309.  
  310.  
  311. ;;;; ehelp-map
  312.  
  313. (defvar ehelp-map nil)
  314. (if ehelp-map
  315.     nil
  316.   (let ((shadow '((describe-key . electric-describe-key) 
  317.                   (describe-mode . electric-describe-mode)
  318.                   (view-lossage . electric-view-lossage) 
  319.                   (describe-function . electric-describe-function)
  320.                   (describe-variable . electric-describe-variable)
  321.                   (describe-bindings . electric-describe-bindings)
  322.                   (describe-syntax . electric-describe-syntax)))
  323.         (map (make-sparse-keymap)))
  324.     (set-keymap-name map 'ehelp-map)
  325.     (set-keymap-parent map help-map)
  326.     ;; Shadow bindings which would be inherited from help-map
  327.     ;;#### This doesn't descend into sub-keymaps
  328.     (map-keymap (function (lambda (key binding)
  329.                               (let ((tem (assq binding shadow)))
  330.                                 (if tem
  331.                                     (define-key map key (cdr tem))))))
  332.                 help-map)
  333.     (setq ehelp-map map)
  334.     (fset 'ehelp-command map)))
  335.  
  336.  
  337. ;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
  338.  
  339. (provide 'ehelp) 
  340.  
  341. ;;; ehelp.el ends here
  342.